home *** CD-ROM | disk | FTP | other *** search
/ Hardcore Visual Basic 5.0 (2nd Edition) / Hardcore Visual Basic 5.0 - Second Edition (1997)(Microsoft Press).iso / Code / LOCALM~1 / comctl.bas < prev    next >
BASIC Source File  |  1997-06-14  |  4KB  |  106 lines
  1. Attribute VB_Name = "MCommonControl"
  2. Option Explicit
  3.  
  4. Public Enum EErrorCommonControl
  5.     eeBaseCommonControl = 13440     ' CommonControl
  6. End Enum
  7.  
  8. ' Helpers for common control functions and image lists
  9.  
  10. Function INDEXTOOVERLAYMASK(i As Long) As Long
  11.     INDEXTOOVERLAYMASK = i * 256
  12. End Function
  13.  
  14. ' ImageList_ReplaceIcon(himl, -1, hicon)
  15. Function ImageList_AddIcon(ByVal himl As Long, ByVal hIcon As Long) As Long
  16.     ImageList_AddIcon = ImageList_ReplaceIcon(himl, -1, hIcon)
  17. End Function
  18.  
  19. ' ImageList_Remove(himl, -1)
  20. Function ImageList_RemoveAll(ByVal himl As Long) As Long
  21.     ImageList_RemoveAll = ImageList_Remove(himl, -1)
  22. End Function
  23.  
  24. ' ImageList_GetIcon(himl, i, 0)
  25. Function ImageList_ExtractIcon(ByVal himl As Long, ByVal i As Long) As Long
  26.     ImageList_ExtractIcon = ImageList_GetIcon(himl, i, 0)
  27. End Function
  28.  
  29. ' ImageList_LoadImage(hi, lpbmp, cx, cGrow, crMask, IMAGE_BITMAP, 0)
  30. Function ImageList_LoadBitmap(ByVal hi As Long, ByVal lpbmp As String, _
  31.     ByVal cx As Long, ByVal cGrow As Long, ByVal crMask As Long, _
  32.     ByVal uType As Long, ByVal uFlags As Long) As Long
  33.     ImageList_LoadBitmap = ImageList_LoadImage(hi, lpbmp, cx, cGrow, _
  34.                                                crMask, IMAGE_BITMAP, 0)
  35. End Function
  36.  
  37. #If fComponent Then
  38. Sub DrawImage(imlst As Object, vIndex As Variant, ByVal hDC As Long, _
  39.               ByVal x As Long, ByVal y As Long, _
  40.               Optional ByVal afDraw As EILD = ILD_TRANSPARENT)
  41. #Else
  42. Sub DrawImage(imlst As Control, vIndex As Variant, ByVal hDC As Long, _
  43.               ByVal x As Long, ByVal y As Long, _
  44.               Optional ByVal afDraw As EILD = ILD_TRANSPARENT)
  45. #End If
  46.     ImageList_Draw imlst.hImageList, _
  47.                    imlst.ListImages(vIndex).Index - 1, hDC, _
  48.                    x / Screen.TwipsPerPixelX, _
  49.                    y / Screen.TwipsPerPixelY, afDraw
  50. End Sub
  51.  
  52.  
  53. ' System image lists
  54.  
  55. Function GetSysImageList(cCount As Long, _
  56.                          Optional ByVal fLargeIcon As Boolean = True) As Long
  57.     Dim shfi As SHFILEINFO
  58.     Dim hSysIm As Long, hIcon As Long, af As Long
  59.     af = SHGFI_SYSICONINDEX Or _
  60.          IIf(fLargeIcon, SHGFI_LARGEICON, SHGFI_SMALLICON)
  61.     hSysIm = SHGetFileInfo(Left$(CurDir$, 3), 0, shfi, Len(shfi), af)
  62.     cCount = ImageList_GetImageCount(hSysIm)
  63.     GetSysImageList = hSysIm
  64. End Function
  65.  
  66. Function GetSysIcon(ByVal hSysIm As Long, ByVal i As Integer, _
  67.                     Optional ByVal xWidth As Long, _
  68.                     Optional ByVal yHeight As Long) As Picture
  69.     Set GetSysIcon = Nothing
  70.     Dim f As Boolean, cx As Long, cy As Long
  71.     Dim iminf As IMAGEINFO
  72.     f = ImageList_GetImageInfo(hSysIm, i, iminf)
  73.     If Not f Then Exit Function
  74.     f = ImageList_GetIconSize(hSysIm, cx, cy)
  75.     If Not f Then Exit Function
  76.     ' These just go to temporary variables if missing
  77.     xWidth = cx
  78.     yHeight = cx
  79.     ' Check for bitmap
  80.     If iminf.hbmMask = hNull Then Exit Function
  81.     ' Get icon handle and convert to picture
  82.     Set GetSysIcon = MPicTool.IconToPicture(ImageList_GetIcon(hSysIm, i, ILD_NORMAL))
  83.     
  84. End Function
  85.  
  86. #If fComponent = 0 Then
  87. Private Sub ErrRaise(e As Long)
  88.     Dim sText As String, sSource As String
  89.     If e > 1000 Then
  90.         sSource = App.ExeName & ".CommonControl"
  91.         Select Case e
  92.         Case eeBaseCommonControl
  93.             BugAssert True
  94.        ' Case ee...
  95.        '     Add additional errors
  96.         End Select
  97.         Err.Raise COMError(e), sSource, sText
  98.     Else
  99.         ' Raise standard Visual Basic error
  100.         sSource = App.ExeName & ".VBError"
  101.         Err.Raise e, sSource
  102.     End If
  103. End Sub
  104. #End If
  105.  
  106.